home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / gnome-games / aisleriot / games / terrace.scm < prev    next >
Encoding:
Text File  |  2009-04-14  |  13.8 KB  |  407 lines
  1. ; AisleRiot - terrace.scm
  2. ; Copyright (C) 2008 Vincent Povirk <madewokherd@gmail.com>
  3. ;
  4. ; This game is free software; you can redistribute it and/or modify
  5. ; it under the terms of the GNU General Public License as published by
  6. ; the Free Software Foundation; either version 2, or (at your option)
  7. ; any later version.
  8. ;
  9. ; This program is distributed in the hope that it will be useful,
  10. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ; GNU General Public License for more details.
  13. ;
  14. ; You should have received a copy of the GNU General Public License
  15. ; along with this program; if not, write to the Free Software
  16. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  17. ; USA
  18.  
  19. (define reserve-size 11)
  20. (define tableau-size 9)
  21. (define build-foundation-in-suit #f)
  22. (define select-base #t)
  23. (define max-redeal 0)
  24. (define auto-fill-tableau #f)
  25. (define fill-from-reserve #f)
  26.  
  27. (define variations
  28.   '((11 9 #f #t 0 #f #f)
  29.     (13 9 #t #t 1 #f #f)
  30.     (11 9 #f #f 0 #f #f)
  31.     (11 9 #f #f 0 #t #f)
  32.     (21 8 #f #f 0 #t #t)
  33.     (10 8 #f #f 0 #f #f)
  34.     (10 9 #f #f 0 #f #f)))
  35.  
  36. (define variation-names
  37.   (list (_"Terrace")
  38.         (_"General Patience")
  39.         (_"Falling Stars")
  40.         (_"Signora")
  41.         (_"Redheads")
  42.         (_"Blondes and Brunettes")
  43.         (_"Wood")))
  44.  
  45. (define current-variation 0)
  46.  
  47. (def-save-var BASE-VAL 0)
  48.  
  49. ; In games where the tableau is not auto-filled, the stock is "locked" when a
  50. ; card is dealt while the tableau has an empty space and "unlocked" when spaces
  51. ; are full or a card is moved out of the waste.
  52. (def-save-var stock-locked #f)
  53.  
  54. (define stock 0)
  55. (define waste 1)
  56. (define reserve 2)
  57. (define foundation '(3 4 5 6 7 8 9 10))
  58. (define tableau '()) ; This will be set by (new-game)
  59.  
  60. (define (new-game)
  61.   (initialize-playing-area)
  62.   (set-ace-low)
  63.  
  64.   (make-standard-double-deck)
  65.   (shuffle-deck)
  66.   
  67.   (add-normal-slot (reverse DECK))
  68.   (add-normal-slot '())
  69.   (add-blank-slot)
  70.   (add-extended-slot '() right)
  71.   (add-carriage-return-slot)
  72.  
  73.   (add-normal-slot '())
  74.   (add-normal-slot '())
  75.   (add-normal-slot '())
  76.   (add-normal-slot '())
  77.   (add-normal-slot '())
  78.   (add-normal-slot '())
  79.   (add-normal-slot '())
  80.   (add-normal-slot '())
  81.   (add-carriage-return-slot)
  82.  
  83.   (set! tableau '())
  84.   (build-tableau-slots tableau-size)
  85.   (set! tableau (reverse tableau))
  86.  
  87.   (deal-reserve-cards reserve-size)
  88.  
  89.   (if select-base
  90.       (begin (deal-tableau-cards tableau 4)
  91.              (set! BASE-VAL 0))
  92.       (begin (deal-cards-face-up stock (list (car foundation)))
  93.              (set! BASE-VAL (get-value (get-top-card (car foundation))))
  94.              (deal-tableau-cards tableau tableau-size)))
  95.  
  96.   (do-auto-deal)
  97.   (give-status-message)
  98.   (update-score)
  99.  
  100.   (list 8 4.1)
  101. )
  102.  
  103. (define (build-tableau-slots count)
  104.   (and (not (= count 0))
  105.        (set! tableau (cons SLOTS tableau))
  106.        (add-extended-slot '() down)
  107.        (set! HORIZPOS (+ HORIZPOS (- 1 (/ tableau-size 8))))
  108.        (build-tableau-slots (- count 1))))
  109.  
  110. (define (deal-reserve-cards count)
  111.   (and (not (= count 0))
  112.        (deal-cards-face-up stock (list reserve))
  113.        (deal-reserve-cards (- count 1))))
  114.  
  115. (define (deal-tableau-cards slots count)
  116.   (and (not (= count 0))
  117.        (not (null? slots))
  118.        (deal-cards-face-up stock (list (car slots)))
  119.        (deal-tableau-cards (cdr slots) (- count 1))))
  120.  
  121.  
  122. (define (give-status-message)
  123.   (set-statusbar-message (string-append (get-stock-no-string)
  124.                                         (get-redeals-string)
  125.                                         "   "
  126.                                         (get-base-string))))
  127.  
  128. (define (get-base-string)
  129.   (cond ((and (> BASE-VAL 1)
  130.               (< BASE-VAL 11))
  131.          (format (_"Base Card: ~a") (number->string BASE-VAL)))
  132.         ((= BASE-VAL 1)
  133.          (_"Base Card: Ace"))
  134.         ((= BASE-VAL 11)
  135.          (_"Base Card: Jack"))
  136.         ((= BASE-VAL 12)
  137.          (_"Base Card: Queen"))
  138.         ((= BASE-VAL 13)
  139.          (_"Base Card: King"))
  140.         (#t "")))
  141.  
  142. (define (get-redeals-string)
  143.   (if (or (< max-redeal 1) (= BASE-VAL 0))
  144.       ""
  145.       (string-append "   " (_"Redeals left:") " "
  146.                      (number->string (- max-redeal FLIP-COUNTER)))))
  147.  
  148. (define (get-stock-no-string)
  149.   (if (= BASE-VAL 0)
  150.       ""
  151.       (string-append (_"Stock left:") " " 
  152.                      (number->string (length (get-cards stock))))))
  153.  
  154. (define (descending-values? a b)
  155.    (or (= b (- a 1))
  156.        (and (= a ace)
  157.             (= b king))))
  158.  
  159. (define (calculate-score slots acc)
  160.   (if (null? slots)
  161.       acc
  162.       (calculate-score (cdr slots) (+ acc (length (get-cards (car slots)))))))
  163.  
  164. (define (update-score)
  165.   (set-score! (calculate-score foundation 0)))
  166.  
  167. (define (do-auto-fill-tableau slots)
  168.   (if (null? slots)
  169.       #t
  170.       (begin (and (empty-slot? (car slots))
  171.                   (cond ((and fill-from-reserve (not (empty-slot? reserve)))
  172.                          (deal-cards-face-up reserve (list (car slots))))
  173.                         ((not (empty-slot? waste))
  174.                          (deal-cards-face-up waste (list (car slots))))
  175.                         ((not (empty-slot? stock))
  176.                          (deal-cards-face-up stock (list (car slots))))))
  177.              (do-auto-fill-tableau (cdr slots)))))
  178.  
  179. (define (do-auto-deal)
  180.   (or (= BASE-VAL 0)
  181.       (not auto-fill-tableau)
  182.       (do-auto-fill-tableau tableau))
  183.   (or (= BASE-VAL 0)
  184.       (not (empty-slot? waste))
  185.       (not (dealable?))
  186.       (do-deal-next-cards))
  187.   #t)
  188.  
  189. (define (button-pressed slot-id card-list)
  190.   (cond ((= BASE-VAL 0) ; If we haven't selected a base, nothing else is allowed
  191.          (member slot-id tableau))
  192.         ((member slot-id tableau)
  193.          (= 1 (length card-list)))
  194.         ((= slot-id reserve)
  195.          #t)
  196.         ((= slot-id waste)
  197.          #t)
  198.         (#t #f)))
  199.  
  200. (define (complete-transaction start-slot card-list end-slot)
  201.   (move-n-cards! start-slot end-slot card-list)
  202.   (or (not (= BASE-VAL 0))
  203.       (begin (set! BASE-VAL (get-value (get-top-card end-slot)))
  204.              (do-auto-fill-tableau tableau)))
  205.   (and (or (= start-slot waste)
  206.            (not (or-map empty-slot? tableau)))
  207.        (set! stock-locked #f))
  208.   (do-auto-deal)
  209.   #t)
  210.  
  211. (define (button-released start-slot card-list end-slot)
  212.   (and (droppable? start-slot card-list end-slot)
  213.        (complete-transaction start-slot card-list end-slot)))
  214.  
  215. (define (droppable? start-slot card-list end-slot)
  216.   (cond ((= BASE-VAL 0) ; If we haven't selected a base, nothing else is allowed
  217.          (and (member start-slot tableau)
  218.               (member end-slot foundation)))
  219.         ((= start-slot stock)
  220.          #f)
  221.         ((member end-slot tableau)
  222.          (and (= 1 (length card-list))
  223.               (not (= start-slot end-slot))
  224.               (not (= start-slot reserve))
  225.               (if (empty-slot? end-slot)
  226.                   (= start-slot waste)
  227.                   (and (not (= (get-color (car card-list))
  228.                                (get-color (get-top-card end-slot))))
  229.                        (descending-values? (get-value (get-top-card end-slot))
  230.                                            (get-value (car card-list)))
  231.                        (not (= (get-value (get-top-card end-slot)) BASE-VAL))))))
  232.         ((member end-slot foundation)
  233.          (if (empty-slot? end-slot)
  234.              (= BASE-VAL (get-value (car card-list)))
  235.              (and (if build-foundation-in-suit
  236.                       (= (get-suit (car card-list))
  237.                          (get-suit (get-top-card end-slot)))
  238.                       (not (= (get-color (car card-list))
  239.                               (get-color (get-top-card end-slot)))))
  240.                   (descending-values? (get-value (car card-list))
  241.                                       (get-value (get-top-card end-slot)))
  242.                   (not (= (get-value (car card-list)) BASE-VAL)))))
  243.         (#t #f)))
  244.  
  245. (define (dealable?)
  246.   (and (not (= 0 BASE-VAL))
  247.        (flippable? stock max-redeal)
  248.        ;Do not allow deals if we've been through the deck once and the waste is not empty
  249.        (or (< FLIP-COUNTER 1)
  250.            (empty-slot? waste))
  251.        (or auto-fill-tableau
  252.            (not stock-locked))))
  253.  
  254. (define (do-deal-next-cards)
  255.   (and (dealable?)
  256.        (flip-stock stock waste max-redeal 1)
  257.        (or (not (or-map empty-slot? tableau))
  258.            (set! stock-locked #t))
  259.        #t))
  260.  
  261. (define (button-clicked start-slot)
  262.   (and (= start-slot stock)
  263.        (do-deal-next-cards)
  264.        #t))
  265.  
  266. (define (auto-play-to-foundation start-slot end-slots)
  267.   (and (not (null? end-slots))
  268.        (not (empty-slot? start-slot))
  269.        (if (droppable? start-slot (list (get-top-card start-slot)) (car end-slots))
  270.            (complete-transaction start-slot (list (remove-card start-slot)) (car end-slots))
  271.            (auto-play-to-foundation start-slot (cdr end-slots)))))
  272.  
  273. (define (button-double-clicked start-slot)
  274.   (auto-play-to-foundation start-slot foundation))
  275.  
  276. (define (hint-start-foundation)
  277.   (and (= BASE-VAL 0)
  278.        (list 2 (_"something") (_"the foundation"))))
  279.  
  280. (define (hint-slot-to-foundation start-slot end-slots)
  281.   (and (not (null? end-slots))
  282.        (not (empty-slot? start-slot))
  283.        (if (droppable? start-slot (list (get-top-card start-slot)) (car end-slots))
  284.            (if (empty-slot? (car end-slots))
  285.                (list 2 (get-name (get-top-card start-slot)) (_"an empty slot on the foundation"))
  286.                (list 1 (get-name (get-top-card start-slot)) (get-name (get-top-card (car end-slots)))))
  287.            (hint-slot-to-foundation start-slot (cdr end-slots)))))
  288.  
  289. (define (hint-slots-to-foundation start-slots)
  290.   (and (not (null? start-slots))
  291.        (or (hint-slot-to-foundation (car start-slots) foundation)
  292.            (hint-slots-to-foundation (cdr start-slots)))))
  293.  
  294. (define (get-rank value)
  295.   (if (< value BASE-VAL)
  296.       (+ 13 value)
  297.       value))
  298.  
  299. (define (droppable-on-foundation start-slot cards end-slots)
  300.   (and (not (null? end-slots))
  301.        (or (droppable? start-slot cards (car end-slots))
  302.            (droppable-on-foundation start-slot cards (cdr end-slots)))))
  303.  
  304. ; We need to check recursively for builds because it might be possible to free
  305. ; a space in the tableau by moving multiple single cards in a row.
  306. (define (buildable-on-tableau start-slot cards acc)
  307.   (or (and (null? cards)
  308.            acc)
  309.       ; If the foundation is building in suit, it's possible that moving cards
  310.       ; within the tableau will allow putting something on a foundation
  311.       (and (droppable-on-foundation start-slot (list (car cards)) foundation)
  312.            acc)
  313.       (let ((target-slot (buildable-on-tableau-helper start-slot (car cards) tableau)))
  314.            (and target-slot
  315.                 (buildable-on-tableau
  316.                      start-slot
  317.                      (cdr cards)
  318.                      (or acc (list (get-rank (get-value (car cards))) 1 (get-name (car cards)) (get-name (get-top-card target-slot)))))))))
  319. (define (buildable-on-tableau-helper start-slot card end-slots)
  320.   (and (not (null? end-slots))
  321.        (or (and (not (empty-slot? (car end-slots)))
  322.                 (droppable? start-slot (list card) (car end-slots))
  323.                 (car end-slots))
  324.            (buildable-on-tableau-helper start-slot card (cdr end-slots)))))
  325.  
  326. (define (hint-tableau-build start-slots acc)
  327.   (if (null? start-slots)
  328.       (cdr acc)
  329.       ; Try to prefer moving cards of higher rank
  330.       (let ((hint (hint-tableau-build-helper (car start-slots))))
  331.            (hint-tableau-build
  332.                (cdr start-slots)
  333.                (if (and hint (> (car hint) (car acc)))
  334.                    hint
  335.                    acc)))))
  336.              
  337.             
  338. (define (hint-tableau-build-helper start-slot)
  339.   (and (not (empty-slot? start-slot))
  340.        (buildable-on-tableau start-slot (get-cards start-slot) #f)))
  341.  
  342. (define (hint-waste-to-tableau end-slots)
  343.   (and (not (null? end-slots))
  344.        (not (empty-slot? waste))
  345.        (if (droppable? waste (list (get-top-card waste)) (car end-slots))
  346.            (if (empty-slot? (car end-slots))
  347.                (list 2 (get-name (get-top-card waste)) (_"an empty slot on the tableau"))
  348.                (list 1 (get-name (get-top-card waste)) (get-name (get-top-card (car end-slots)))))
  349.            (hint-waste-to-tableau (cdr end-slots)))))
  350.  
  351. (define (hint-deal)
  352.   (and (dealable?)
  353.        (list 0 (_"Deal a new card from the deck"))))
  354.  
  355. (define (get-hint)
  356.   (or (hint-start-foundation)
  357.       (hint-slot-to-foundation reserve foundation)
  358.       (hint-slots-to-foundation tableau)
  359.       (hint-slot-to-foundation waste foundation)
  360.       (hint-tableau-build tableau (cons BASE-VAL #f))
  361.       (hint-waste-to-tableau tableau)
  362.       (hint-deal)))
  363.  
  364. (define (game-won)
  365.   (= (get-score) 104))
  366.  
  367. (define (game-continuable)
  368.   (give-status-message)
  369.   (update-score)
  370.   (and (not (game-won))
  371.        (get-hint)))
  372.  
  373. (define (get-variation-options names index)
  374.   (if (null? names)
  375.       '()
  376.       (cons (list (car names) (= current-variation index))
  377.             (get-variation-options (cdr names) (+ 1 index)))))
  378.  
  379. (define (get-options)
  380.   (append '(begin-exclusive)
  381.           (get-variation-options variation-names 0)
  382.           '(end-exclusive)))
  383.  
  384. (define (set-variation vars options index)
  385.   (or (null? vars)
  386.       (and (cadar options)
  387.            (set! current-variation index)
  388.            (set! reserve-size (list-ref (car vars) 0))
  389.            (set! tableau-size (list-ref (car vars) 1))
  390.            (set! build-foundation-in-suit (list-ref (car vars) 2))
  391.            (set! select-base (list-ref (car vars) 3))
  392.            (set! max-redeal (list-ref (car vars) 4))
  393.            (set! auto-fill-tableau (list-ref (car vars) 5))
  394.            (set! fill-from-reserve (list-ref (car vars) 6)))
  395.       (set-variation (cdr vars) (cdr options) (+ index 1))))
  396.  
  397. (define (apply-options options)
  398.   (set-variation variations (cdr options) 0))
  399.  
  400. (define (timeout) #f)
  401.  
  402. (set-features droppable-feature dealable-feature)
  403.  
  404. (set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-continuable game-won get-hint get-options apply-options timeout droppable? dealable?)
  405.  
  406.  
  407.